unit uDZHttp;

interface

uses
  SysUtils, Classes, OverbyteIcsHttpProt, OverbyteIcsWndControl,
  uDZSysUtils, uDZCommonInterface;

type
  IHttpClient = interface(IBaseInterface)
    function GetUserAgent: AnsiString;
    procedure SetUserAgent(const value: AnsiString);
    function GetPostContentType: AnsiString;
    procedure SetPostContentType(const value: AnsiString);
    procedure Get(url: string; data: TStream);
    procedure Post(url: string; upload, data: TStream);
    procedure Abort;
    function GetEventHandler: IProgressNotify;
    procedure SetEventHandler(const value: IProgressNotify);
    property UserAgent: AnsiString read GetUserAgent write SetUserAgent;
    property PostContentType: AnsiString read GetPostContentType write SetPostContentType;
    property EventHandler: IProgressNotify
      read GetEventHandler write SetEventHandler;
  end;

  TIcsHttpClient = class(TInterfacedObject, IHttpClient)
  private
    fImpl: THttpCli;
    fContentLength: Integer;
    fEventHandler: IProgressNotify;
    procedure OnDocData(Sender: TObject; Buffer: Pointer; Len: Integer);
    procedure OnHeaderData(Sender: TObject);
    function GetEventHandler: IProgressNotify;
    procedure SetEventHandler(const value: IProgressNotify);
  protected
    function GetUserAgent: AnsiString;
    procedure SetUserAgent(const value: AnsiString);
    function GetPostContentType: AnsiString;
    procedure SetPostContentType(const value: AnsiString);
  public
    constructor Create;
    destructor Destroy; override;
    procedure Get(url: string; data: TStream);
    procedure Post(url: string; upload, data: TStream);
    procedure Abort;
  end;

  function HttpGet(client: IHttpClient; const url: AnsiString): AnsiString;

function WideURLEncode(const src: WideString): AnsiString;
function URLEncode(const src: UTF8String): AnsiString;

implementation

uses
  uDZStrUtils;

function URLEncode(const src: UTF8String): AnsiString;
var
  Idx: Integer;
  pch: PAnsiChar;
  ch: Byte;
const
  HEX_CHARS: array [0..15] of AnsiChar =
    ('0', '1', '2', '3', '4', '5', '6', '7',
     '8', '9', 'A', 'B', 'C', 'D', 'E', 'F');
begin
  SetLength(Result, 3 * Length(src));
  pch := PAnsiChar(Result);
  for Idx := 1 to Length(src) do
  begin
    case Src[Idx] of
      'A'..'Z', 'a'..'z', '0'..'9', '-', '_', '.':
        begin
          pch^ := src[Idx];
          Inc(pch);
        end;
      else begin
        pch^ := '%';
        Inc(pch);
        ch := Ord(src[Idx]);
        pch^ := HEX_CHARS[ch shr 4];
        Inc(pch);
        pch^ := HEX_CHARS[ch and $0f];
        Inc(pch);
      end;
    end;
  end;
  SetLength(Result, pch - PAnsiChar(Result));
end;

function WideURLEncode(const src: WideString): AnsiString;
begin
  Result := URLEncode(Utf8Encode(src));
end;

function HttpGet(client: IHttpClient; const url: AnsiString): AnsiString;
var
  ss: TAnsiStringStream;
begin
  Result := '';
  ss := TAnsiStringStream.Create('');
  try
    client.Get(url, ss);
    Result := ss.DataString;
  finally
    ss.Free;
  end;
end;

{ TIcsHttpClient }

procedure TIcsHttpClient.Abort;
begin

end;

constructor TIcsHttpClient.Create;
begin
  fImpl := THttpCli.Create(nil);
  fImpl.OnDocData := Self.OnDocData;
  fImpl.OnHeaderData := Self.OnHeaderData;
end;

destructor TIcsHttpClient.Destroy;
begin
  fImpl.Free;
  inherited;
end;

procedure TIcsHttpClient.Get(url: string; data: TStream);
begin
  fContentLength := 0;
  fImpl.URL := url;
  fImpl.RcvdStream := data;
  fImpl.Get;
end;

function TIcsHttpClient.GetPostContentType: AnsiString;
begin
  Result := fImpl.ContentTypePost;
end;

function TIcsHttpClient.GetEventHandler: IProgressNotify;
begin
  Result := fEventHandler;
end;

function TIcsHttpClient.GetUserAgent: AnsiString;
begin
  Result := fImpl.Agent;
end;

procedure TIcsHttpClient.OnDocData(Sender: TObject;
  Buffer: Pointer; Len: Integer);
begin
  if (fEventHandler <> nil) then
    fEventHandler.SetProgress(fContentLength, fImpl.RcvdCount);
end;

procedure TIcsHttpClient.OnHeaderData(Sender: TObject);
var
  header, num: string;
  nums, nume: Integer;
begin
  if (fEventHandler = nil) then Exit;
  header := LowerCase(fImpl.LastResponse);
  if (Pos('content-length', header) = 1) then
  begin
    nums := Pos(':', header);
    while (not (header[nums] in ['0'..'9'])) do Inc(nums);
    nume := nums;
    while ((nume <= Length(header)) and
      (header[nume] in ['0'..'9'])) do Inc(nume);
    if (nume > Length(header)) then nume := Length(header);
    num := Copy(header, nums, nume - nums + 1);
    fContentLength := StrToInt(num);
    fEventHandler.SetProgressMax(fContentLength);
  end;
end;

procedure TIcsHttpClient.Post(url: string; upload, data: TStream);
begin
  fContentLength := 0;
  fImpl.URL := url;
  fImpl.SendStream := upload;
  fImpl.RcvdStream := data;
  fImpl.Post;
end;

procedure TIcsHttpClient.SetPostContentType(const value: AnsiString);
begin
  fImpl.ContentTypePost := value;
end;

procedure TIcsHttpClient.SetEventHandler(const value: IProgressNotify);
begin
  fEventHandler := value;
end;

procedure TIcsHttpClient.SetUserAgent(const value: AnsiString);
begin
  fImpl.Agent := value;
end;

end.
